home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / NAE2.FOR < prev    next >
Encoding:
Text File  |  1988-02-08  |  11.0 KB  |  366 lines
  1.       SUBROUTINE NAE2 ( NREAD, NWRITE, NUM, MAX, IARRAY,
  2.      $                  IARRAY2, ERROR )
  3. C*
  4. C*                  *******************************
  5. C*                  *******************************
  6. C*                  **                           **
  7. C*                  **          NAE2             **
  8. C*                  **                           **
  9. C*                  *******************************
  10. C*                  *******************************
  11. C*
  12. C*     SUBPROGRAM :
  13. C*          NIFTY ARRAY EDITOR 2
  14. C*
  15. C*     AUTHOR :
  16. C*          ART RAGOSTA
  17. C*          MS 207-5
  18. C*          AMES RESEARCH CENTER
  19. C*          MOFFETT FIELD, CALIF  94035
  20. C*          (415) 694-5578
  21. C*
  22. C*     PURPOSE :
  23. C*          TO ENABLE THE SCREEN-ORIENTED EDITING OF 2 ARRAYS.
  24. C*
  25. C*     METHODOLOGY :
  26. C*          USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.
  27. C*
  28. C*     INPUT ARGUMENTS :
  29. C*          NREAD  - KEYBOARD LOGICAL UNIT NUMBER.
  30. C*          NWRITE - SCREEN LOGICAL UNIT NUMBER.
  31. C*          NUM    - NUMBER OF ELEMENTS IN ARRAYS.
  32. C*          MAX    - THE DIMENSION OF ARRAYS.
  33. C*          IARRAY - THE FIRST DATA ARRAY.
  34. C*          IARRAY2- THE SECOND DATA ARRAY.
  35. C*
  36. C*     OUTPUT ARGUMENTS :
  37. C*          ERROR  - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.
  38. C*
  39. C*     INTERNAL WORK AREAS :
  40. C*          STRING - TEMPORARY STORAGE FOR INPUT STRING.
  41. C*
  42. C*     COMMON BLOCKS :
  43. C*          NONE
  44. C*
  45. C*     FILE REFERENCES :
  46. C*          NREAD, NWRITE
  47. C*
  48. C*     DATA BASE ACCESS :
  49. C*          NONE
  50. C*
  51. C*     SUBPROGRAM REFERENCES :
  52. C*          CLEAR,  NSTAT,  WRITA2,  GOTOXY,  CAPS,   LEFT,  MBELL
  53. C*          STAT,   WAIT,   WRITL2,  REVLF,   GETOKE, RIGHT, SRESET
  54. C*
  55. C*     ERROR PROCESSING :
  56. C*          CHECK FOR VALID COMMANDS.
  57. C*          CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.
  58. C*
  59. C*     TRANSPORTABILITY LIMITATIONS :
  60. C*          NOT TRANSPORTABLE.
  61. C*
  62. C*     ASSUMPTIONS AND RESTRICTIONS :
  63. C*          VT-100 COMPATIBLE TERMINALS ONLY.
  64. C*
  65. C*     LANGUAGE AND COMPILER :
  66. C*          ANSI FORTRAN 77
  67. C*
  68. C*     VERSION AND DATE :
  69. C*          VERSION I.0      4-FEB-85
  70. C*
  71. C*     CHANGE HISTORY :
  72. C*           4-FEB-85    INITIAL VERSION
  73. C*
  74. C***********************************************************************
  75. C*
  76.       CHARACTER *80 STRING
  77.       CHARACTER *20 TOKE
  78.       CHARACTER *1 ESC, TYPE
  79.       LOGICAL ERROR, DOWN, ERR
  80.       DIMENSION IARRAY(MAX), IARRAY2(MAX)
  81.       DATA ESC/27/
  82. C
  83. C  NUM    - THE NUMBER OF ELEMENTS IN IARRAY
  84. C  MAX    - THE MAXIMUM DIMENSION OF IARRAY
  85. C  IARRAY - THE DATA TO BE EDITED
  86. C  IARRAY2- THE DATA TO BE EDITED
  87. C  NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )
  88. C  ERROR  - INTERNAL ERROR FLAG
  89. C  DOWN   - .TRUE. IF THE DEFAULT DIRECTION IS DOWN
  90. C  IPTR   - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO
  91. C  IX     - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)
  92. C  IY     - Y LOCATION OF CURSOR (BETWEEN 2 AND 24)
  93. C  NREAD  - KEYBOARD UNIT NUMBER
  94. C  NWRITE - SCREEN UNIT NUMBER
  95. C  STRING - INPUT BUFFER
  96. C  ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREEN
  97. C
  98.       ERROR = .FALSE.
  99.       NARRAY = 2
  100.       IF ( NUM .GT. MAX ) THEN
  101.          ERROR = .TRUE.
  102.          RETURN
  103.       ENDIF
  104.       DOWN = .TRUE.
  105.       IX   = 1
  106.       IY   = 2
  107. C
  108. C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYS
  109. C
  110.       IPTR = 0
  111.       IF ( NUM .GE. 1 ) IPTR = 1
  112.       ISTART = IPTR
  113.       CALL NSTAT ( IX, IY, NUM, DOWN )
  114.       CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  115.       CALL GOTOXY ( NWRITE, IX, IY )
  116. C
  117. C --- REPEAT UNTIL DONE
  118. C
  119. 100   READ ( NREAD, 900, END=1000, ERR=1000 ) STRING
  120.       CALL CAPS ( STRING )
  121.       CALL LEFT ( STRING )
  122.       IF (STRING(1:1) .EQ. 'A') THEN
  123. C
  124. C ----- 'ADD' COMMAND
  125. C
  126.          IF (NUM .EQ. MAX) THEN
  127.             CALL MBELL ( NWRITE )
  128.             CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' )
  129.             CALL WAIT ( 3 )
  130.             CALL NSTAT ( IX, IY, NUM, DOWN )
  131.          ELSE
  132.             IARRAY(NUM+1) = 0
  133.             IARRAY2(NUM+1) = 0
  134.             NUM = NUM + 1
  135.             CALL NSTAT ( IX, IY, NUM, DOWN )
  136.             ISTART = NUM - 21
  137.             IF (ISTART .LE. 0)ISTART = 1
  138.             IF (NUM .EQ. 0 )ISTART = 0
  139.             CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  140.             IPTR = NUM
  141.             IY = MIN0 ( NUM+1, 23 )
  142.             IF (NUM .EQ. 0) IY = 2
  143.             CALL GOTOXY ( NWRITE, IX, IY )
  144.          ENDIF
  145.       ELSE IF (STRING(1:1) .EQ. 'B') THEN
  146. C
  147. C ----- 'BEGIN' COMMAND
  148. C
  149.          IPTR = 0
  150.          IF (NUM .GE. 1) IPTR = 1
  151.          ISTART = IPTR
  152.          CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  153.          IY = 2
  154.          CALL GOTOXY ( NWRITE, IX, IY )
  155. C
  156.       ELSE IF (STRING(1:1) .EQ. 'D') THEN
  157. C
  158. C ----- 'DELETE' COMMAND
  159. C
  160.          IF (NUM .GT. 0) THEN
  161.             NUM = NUM - 1
  162.             IF (IPTR .EQ. NUM+1) THEN
  163.                IPTR = NUM
  164.                ISTART = ISTART - 1
  165.                IF ( ISTART .LE. 0 ) THEN
  166.                   ISTART = 1
  167.                   IY = IY - 1
  168.                ENDIF
  169.             ELSE
  170.                DO 110 II = IPTR, NUM
  171.                   IARRAY(II) = IARRAY(II+1)
  172.                   IARRAY2(II) = IARRAY2(II+1)
  173. 110               CONTINUE
  174.                IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1
  175.                IF ( ISTART .LE. 0 )ISTART = 1
  176.             ENDIF
  177.             IF (NUM .EQ. 0) THEN
  178.                ISTART = 0
  179.                IY = 2
  180.             ENDIF
  181.             CALL NSTAT ( IX, IY, NUM, DOWN )
  182.             CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  183.          ENDIF
  184.          CALL GOTOXY ( NWRITE, IX, IY )
  185. C
  186.       ELSE IF (STRING(1:1) .EQ. 'E') THEN
  187. C
  188. C ----- 'END' COMMAND
  189. C
  190.          ISTART = NUM - 21
  191.          IF (ISTART .LE. 0)ISTART = 1
  192.          IF (NUM .EQ. 0 )ISTART = 0
  193.          CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  194.          IPTR = NUM
  195.          IY = MIN0 ( NUM+1, 23 )
  196.          IF (NUM .EQ. 0) IY = 2
  197.          CALL GOTOXY ( NWRITE, IX, IY )
  198. C
  199.       ELSE IF (STRING(1:1) .EQ. 'I') THEN
  200. C
  201. C ----- 'INSERT' COMMAND
  202. C
  203.          IF (NUM .EQ. MAX) THEN
  204.             CALL MBELL ( NWRITE )
  205.             CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' )
  206.             CALL WAIT ( 3 )
  207.             CALL NSTAT ( IX, IY, NUM, DOWN )
  208.          ELSE
  209.             IF (IPTR .LE. NUM) THEN
  210.                DO 120 II = NUM, IPTR, -1
  211.                   IARRAY(II+1) = IARRAY(II)
  212.                   IARRAY2(II+1) = IARRAY2(II)
  213. 120               CONTINUE
  214.                IARRAY(IPTR) = 0
  215.                IARRAY2(IPTR) = 0
  216.             ELSE
  217.                IARRAY(NUM+1) = 0
  218.                IARRAY2(NUM+1) = 0
  219.             ENDIF
  220.             NUM = NUM + 1
  221.             CALL NSTAT ( IX, IY, NUM, DOWN )
  222.             CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  223.             CALL GOTOXY ( NWRITE, IX, IY )
  224.          ENDIF
  225. C
  226.       ELSE IF (STRING(1:1) .EQ. 'Q') THEN
  227.          GO TO 1000
  228. C
  229.       ELSE IF (STRING(1:1) .EQ. 'R') THEN
  230. C
  231. C ----- 'REPAINT' SCREEN
  232. C
  233.          CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  234.          CALL GOTOXY ( NWRITE, IX, IY )
  235. C
  236.       ELSE IF (STRING(1:1) .EQ. 'S') THEN
  237. C
  238. C ----- 'SCROLL' DIRECTION TOGGLE
  239. C
  240.          DOWN = .NOT. DOWN
  241.          CALL NSTAT ( IX, IY, NUM, DOWN )
  242.          CALL GOTOXY ( NWRITE, IX, IY )
  243. C
  244.       ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THEN
  245. C
  246. C ----- 'HELP' COMMAND
  247. C
  248.          CALL CLEAR
  249.          WRITE ( NWRITE, 910 )
  250.          READ ( NREAD, 920 )
  251.          CALL CLEAR
  252.          CALL NSTAT ( IX, IY, NUM, DOWN )
  253.          CALL WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )
  254.          CALL GOTOXY ( NWRITE, IX, IY )
  255.       ELSE
  256. C
  257. C ----- INPUT LINE
  258. C
  259.          IF ( LENGTH(STRING) .EQ. 0 ) THEN
  260. C
  261. C -------- POSITION CURSOR ONLY
  262. C
  263.             IF ( DOWN ) THEN
  264.                IF ( IPTR .LT. NUM ) THEN
  265.                   IPTR = IPTR + 1
  266.                   IY = IY + 1
  267.                   IF ( IY .GT. 23 ) THEN
  268. C
  269. C  --------------  SCROLL UP
  270. C
  271.                      IY = 23
  272.                      ISTART = ISTART + 1
  273.                      CALL WRITL2 ( NWRITE, IY+1, IPTR, IARRAY, IARRAY2 )
  274.                      WRITE ( NWRITE, 940 )
  275.                      CALL REVLF ( NWRITE )
  276.                   ENDIF
  277.                ELSE
  278.                   CALL REVLF ( NWRITE )
  279.                ENDIF
  280.             ELSE
  281.                IF ( IPTR .GT. 1 ) THEN
  282.                   IPTR = IPTR - 1
  283.                   IY = IY - 1
  284.                   IF (IY .LT. 2 ) THEN
  285. C
  286. C  --------------  DOWN SCROLL
  287. C
  288.                      IY = 2
  289.                      ISTART = IPTR
  290.                      CALL GOTOXY ( NWRITE, IX, IY )
  291.                      WRITE ( NWRITE, 930 ) ESC
  292.                      CALL WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 )
  293.                   ENDIF
  294.                ENDIF
  295.                CALL GOTOXY ( NWRITE, IX, IY )
  296.             ENDIF
  297.          ELSE
  298. C
  299. C ------ MODIFY LINE
  300. C
  301.             IL = 1
  302.             IA = 0
  303. 200         CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )
  304.             IF ( TYPE .EQ. 'E' ) THEN
  305.                CALL WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 )
  306.                GO TO 100
  307.             ENDIF
  308.             IF (( TYPE .NE. 'I' ) .OR. ERR ) THEN
  309.                CALL MBELL ( NWRITE )
  310.                CALL STAT ( IX, IY, ' Unintelligible input. ' )
  311.                CALL WAIT ( 3 )
  312.                CALL NSTAT ( IX, IY, NUM, DOWN )
  313.                CALL WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 )
  314.                GO TO 100
  315.             ENDIF
  316.             IA = IA + 1
  317.             IF ( IA .GT. NARRAY ) THEN
  318.                CALL MBELL ( NWRITE )
  319.                CALL STAT ( IX, IY, ' Extra data on line ignored. ' )
  320.                CALL WAIT ( 3 )
  321.                CALL NSTAT ( IX, IY, NUM, DOWN )
  322.                CALL WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 )
  323.                GO TO 100
  324.             ENDIF
  325. C
  326. C -------  PUT NEW VALUE IN ARRAY
  327. C
  328.             CALL RIGHT ( TOKE )
  329.             IF ( IA .EQ. 1 ) THEN
  330.                READ ( TOKE, 950 ) IARRAY ( IPTR )
  331.             ELSE
  332.                READ ( TOKE, 950 ) IARRAY2 ( IPTR )
  333.             ENDIF
  334.             GO TO 200
  335.          ENDIF
  336.       ENDIF
  337.       GO TO 100
  338. C
  339. C --- END REPEAT UNTIL
  340. C
  341. 1000  CALL SRESET ( NWRITE )
  342.       CALL CLEAR
  343.       RETURN
  344. 900   FORMAT ( A80 )
  345. 910   FORMAT (///,' A command is a line with a single letter on it :',/,
  346.      $ '    A)dd     - add a blank line to the end of the arrays',/,
  347.      $ '    B)egin   - go to the beginning of the arrays',/,
  348.      $ '    D)elete  - delete the current line',/,
  349.      $ '    E)nd     - go to the end of the arrays',/,
  350.      $ '    I)nsert  - insert a line before the indicated line',/,
  351.      $ '    Q)uit    - exit the editor',/,
  352.      $ '    R)epaint - repaint the screen',/,
  353.      $ '    S)croll  - change the direction of scrolling',/,
  354.      $ '    ? - produce this message',///,
  355.      $ ' Any other line is expected to be data.  Enter ^Z (control/Z)',
  356.      $ /,'  to exit the editor.',//,
  357.      $ ' Enter <CR> to continue.')
  358. 920   FORMAT ( A )
  359. 930   FORMAT ('+',A1,'M',$ )
  360. 940   FORMAT ( / )
  361. 950   FORMAT ( 10X,I10 )
  362.       END
  363. C
  364. C---END NAE2
  365. C
  366.